## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──
## ✓ ggplot2 3.3.5 ✓ purrr 0.3.4
## ✓ tibble 3.1.6 ✓ dplyr 1.0.7
## ✓ tidyr 1.1.4 ✓ stringr 1.4.0
## ✓ readr 2.0.1 ✓ forcats 0.5.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()
R1<-read.csv("round1_updated.csv")
str(R1)
## 'data.frame': 1525 obs. of 46 variables:
## $ game_name : chr "color trick 1" "color trick 1" "color trick 1" "color trick 1" ...
## $ userid : chr "user1" "user1" "user1" "user1" ...
## $ sessionid : chr "631d4ef0-32a3-4145-8847-d9995b9bf6a3" "631d4ef0-32a3-4145-8847-d9995b9bf6a3" "631d4ef0-32a3-4145-8847-d9995b9bf6a3" "631d4ef0-32a3-4145-8847-d9995b9bf6a3" ...
## $ event_type : chr "trial" "trial" "trial" "trial" ...
## $ is_response_correct : logi TRUE TRUE TRUE TRUE TRUE NA ...
## $ trial_timestamp : chr "2020-10-08T18:44:32.349Z" "2020-10-08T18:44:33.916Z" "2020-10-08T18:44:35.450Z" "2020-10-08T18:44:29.616Z" ...
## $ trial_number : int 7 8 9 5 6 NA 1 2 3 4 ...
## $ user_response : chr "[\"blue\"]" "[\"black\"]" "[\"orange\"]" "[\"red\"]" ...
## $ correct_response : chr "[\"blue\"]" "[\"black\"]" "[\"orange\"]" "[\"red\"]" ...
## $ response_reaction_time : num 844 827 577 711 586 ...
## $ response_timestamp : chr "2020-10-08T18:44:33.192Z" "2020-10-08T18:44:34.742Z" "2020-10-08T18:44:36.026Z" "2020-10-08T18:44:30.326Z" ...
## $ correct_count : int 7 8 9 5 6 9 1 2 3 4 ...
## $ incorrect_count : int 0 0 0 0 0 0 0 0 0 0 ...
## $ mechanic_name : chr "meaning to meaning" "meaning to meaning" "meaning to meaning" "meaning to meaning" ...
## $ total_help_time : num 0 0 0 0 0 NA 0 0 0 0 ...
## $ attempted : logi NA NA NA NA NA NA ...
## $ response_timeout : logi NA NA NA NA NA NA ...
## $ score : int 7 8 9 5 6 NA 1 2 3 4 ...
## $ trial_timeout_duration : num NA NA NA NA NA NA NA NA NA NA ...
## $ total_trials : int 9 9 9 9 9 9 9 9 9 9 ...
## $ character_revealed : logi NA NA NA NA NA NA ...
## $ level_character_distractor : chr "" "" "" "" ...
## $ level_character_target : chr "" "" "" "" ...
## $ level_distractor_probability: num NA NA NA NA NA NA NA NA NA NA ...
## $ level_max_interval : num NA NA NA NA NA NA NA NA NA NA ...
## $ level_min_interval : num NA NA NA NA NA NA NA NA NA NA ...
## $ stimuli_delay_time : num NA NA NA NA NA NA NA NA NA NA ...
## $ stimuli_type : chr "" "" "" "" ...
## $ fastest_reaction_time : num NA NA NA NA NA NA NA NA NA NA ...
## $ median_reaction_time : num NA NA NA NA NA NA NA NA NA NA ...
## $ time_left : num NA NA NA NA NA NA NA NA NA NA ...
## $ time_up : logi NA NA NA NA NA NA ...
## $ timer_duration : num NA NA NA NA NA NA NA NA NA NA ...
## $ hand_color : chr "" "" "" "" ...
## $ moving_direction : chr "" "" "" "" ...
## $ pointing_direction : chr "" "" "" "" ...
## $ average_reaction_time : num NA NA NA NA NA 896 NA NA NA NA ...
## $ options : chr "[{\"color\":\"brown\",\"isanswer\":false,\"text\":\"green\"},{\"color\":\"orange\",\"isanswer\":true,\"text\":\"| __truncated__ "[{\"color\":\"orange\",\"isanswer\":false,\"text\":\"green\"},{\"color\":\"blue\",\"isanswer\":true,\"text\":\""| __truncated__ "[{\"color\":\"brown\",\"isanswer\":true,\"text\":\"orange\"},{\"color\":\"blue\",\"isanswer\":false,\"text\":\""| __truncated__ "[{\"color\":\"blue\",\"isanswer\":false,\"text\":\"yellow\"},{\"color\":\"green\",\"isanswer\":true,\"text\":\""| __truncated__ ...
## $ question : chr "[{\"color\":\"pink\",\"text\":\"blue\"}]" "[{\"color\":\"pink\",\"text\":\"black\"}]" "[{\"color\":\"green\",\"text\":\"orange\"}]" "[{\"color\":\"blue\",\"text\":\"red\"}]" ...
## $ question_prompt : chr "select the option which has the same meaning as the word in the top box." "select the option which has the same meaning as the word in the top box." "select the option which has the same meaning as the word in the top box." "select the option which has the same meaning as the word in the top box." ...
## $ level_start_timestamp : chr "2020-10-08T18:44:08.297Z" "2020-10-08T18:44:08.297Z" "2020-10-08T18:44:08.297Z" "2020-10-08T18:44:08.297Z" ...
## $ level_end_timestamp : chr "" "" "" "" ...
## $ level_total_time : int NA NA NA NA NA 29958 NA NA NA NA ...
## $ session_complete : logi NA NA NA NA NA NA ...
## $ session_start_timestamp : chr "" "" "" "" ...
## $ session_end_timestamp : chr "" "" "" "" ...
R5<- R5%>%
filter(level_start_timestamp != "2021-03-25T18:55:58.767Z")
head(R1$userid)
## [1] "user1" "user1" "user1" "user1" "user1" "user1"
head(R4$userid)
## [1] "user1" "user1" "user1" "user1" "user1" "user1"
R1<-mutate(R1, semester=1, timepoint=1, ID = as.factor(as.numeric(gsub("user", "", userid))+100))
R2<-mutate(R2, semester=1, timepoint=2, ID = as.factor(as.numeric(gsub("user", "", userid))+100))
R3<-mutate(R3, semester=1, timepoint=3, ID = as.factor(as.numeric(gsub("user", "", userid))+100))
R4<-mutate(R4, semester=2, timepoint=1, ID = as.factor(as.numeric(gsub("user", "", userid))+200))
R5<-mutate(R5, semester=2, timepoint=2, ID = as.factor(as.numeric(gsub("user", "", userid))+200))
R6<-mutate(R6, semester=2, timepoint=3, ID = as.factor(as.numeric(gsub("user", "", userid))+200))
#Now unique across timepoints
head(R1$ID)
## [1] 101 101 101 101 101 101
## 19 Levels: 101 102 103 104 105 106 107 108 109 111 112 113 114 115 116 ... 140
head(R4$ID)
## [1] 201 201 201 201 201 201
## Levels: 201 202 203 204 205 206 207 208 209 210 211 212 213 214
#Can combine with new unique IDs
Full<-rbind(R1, R2, R3, R4, R5, R6)
Full <- Full%>%
filter(ID != 140)
nrow(Full)
## [1] 7343
Full%>%
group_by(ID)%>%
summarize(n())
## # A tibble: 33 × 2
## ID `n()`
## <fct> <int>
## 1 101 250
## 2 102 279
## 3 103 221
## 4 104 251
## 5 105 173
## 6 106 260
## 7 107 233
## 8 108 255
## 9 109 231
## 10 111 243
## # … with 23 more rows
smile <- read.csv("SMILE full data 10 23 21_AARThesis_Deidentified_forNL.csv")
smile2 <- pivot_longer(smile,
cols = c(PHQ_T1_total, PHQ_T2_total, PHQ_T3_total),
names_to = "Time",
values_to = "PHQ.Score")
smile2 <- mutate(smile2, numTime = case_when(Time == "PHQ_T1_total" ~ 1,
Time == "PHQ_T2_total" ~ 2,
Time == "PHQ_T3_total" ~ 3))
smile2 <- select(smile2, StudyID_T1, numTime, PHQ.Score)
#We now have only 3 variables: ID, timepoint, and PHQ
str(smile2)
## tibble [435 × 3] (S3: tbl_df/tbl/data.frame)
## $ StudyID_T1: int [1:435] 22585442 22585442 22585442 22585444 22585444 22585444 22585436 22585436 22585436 22585450 ...
## $ numTime : num [1:435] 1 2 3 1 2 3 1 2 3 1 ...
## $ PHQ.Score : num [1:435] 16 12 13 12 5 ...
IntKey <- read.csv("NeurUX.Intervention.Group.csv")
head(IntKey)
## X Study.ID NeurUX.ID Headspace.ID Intervention.Group
## 1 Spring 2021 NA NA
## 2 22585612 user3 SCILOY-LY3NC4 1
## 3 22585613 user14 SCILOY-C2APOH 1
## 4 22585614 user9 SCILOY-8CVNJR 1
## 5 22585616 user6 SCILOY-AVW0KG 1
## 6 22585619 user7 SCILOY-994GC6 1
IntKey[15:19,]
## X Study.ID NeurUX.ID Headspace.ID Intervention.Group
## 15 22585630 user11 SCILOY-48YPVL 0
## 16 NA NA
## 17 Fall 2020 NA NA
## 18 22585580 user1 SCILOY-139ZCT 1
## 19 22585581 user7 SCILOY-NDWT0Q 1
sem1 <- IntKey[18:36, 2]
sem2 <- IntKey[2:15, 2]
IntKey <- mutate(IntKey, semester = case_when(Study.ID %in% sem1 ~ 1,
Study.ID %in% sem2 ~ 2),
Int.Fac = factor(Intervention.Group,
levels = c(0, 1),
labels = c("Control", "Intervention")))
#From there, we use similar code as what we did in the NeuroUX dataset
IntKey1 <-filter(IntKey, semester == 1)
IntKey1 <- mutate(IntKey1, ID = as.factor(as.numeric(gsub("user", "", NeurUX.ID))+100))
IntKey2 <-filter(IntKey, semester == 2)
IntKey2 <- mutate(IntKey2, ID = as.factor(as.numeric(gsub("user", "", NeurUX.ID))+200))
IntKey <-rbind(IntKey1, IntKey2)
Merge.1 <- merge(
x = Full,
y = IntKey,
by.x = "ID",
by.y = "ID"
)
Merge.2 <- merge(
x = Merge.1,
y = smile2,
by.x = c("Study.ID", "timepoint"),
by.y = c("StudyID_T1", "numTime")
)
levels(as.factor(Merge.2$game_name))
## [1] "color trick 1" "color trick 2" "color trick 3"
## [4] "hand swype" "playlist" "quick tap level 2"
We see there are five different games in the dataset as well as a “playlist” variable
comp.data <- filter(Merge.2, game_name == "playlist")
COMP <- c("ID", "timepoint", "session_complete", "session_start_timestamp", "session_end_timestamp")
comp.data <- comp.data[COMP]
comp.data <- filter(comp.data, session_complete == TRUE)
#We have 87 total timepoints with completed data
sum(comp.data$session_complete, na.rm = TRUE)
## [1] 87
timepoints <- comp.data%>%
group_by(ID)%>%
summarize(n())
timepoints
## # A tibble: 33 × 2
## ID `n()`
## <fct> <int>
## 1 101 3
## 2 102 3
## 3 103 3
## 4 104 3
## 5 105 2
## 6 106 3
## 7 107 3
## 8 108 3
## 9 109 3
## 10 111 3
## # … with 23 more rows
sum(timepoints$'n()' == 3)
## [1] 24
sum(timepoints$'n()' == 2)
## [1] 6
sum(timepoints$'n()' == 1)
## [1] 3
We aren’t using this for this study, but it could be useful for cross-checking datasets or confirming with Dr. Silton.
#Removing playlist from future analysis
Merge.2 <- filter(Merge.2, game_name != "playlist")
## tot.over.5 prop.over.5 tot.eq.0 prop.eq.0 total
## 1 30 0.01149425 0 0 2610
A small proportion of trials take over five seconds (not likely due to thinking about or processing the question). Only 30 of the 2610 responses fall into this category. We should likely drop these for calculation and chose to moving forward.
## tot.over.5 prop.over.5 tot.eq.0 prop.eq.0 total
## 1 35 0.01118211 87 0.02779553 3130
Similarly, it was rare to take longer than 5 seconds to respond to hand swype. 35 out of 3130 were greater than 5s. 87 were equal to 0 (this represents the total number of trials, since all ended with a timeout)
## tot.over.5 prop.over.5 tot.eq.0 prop.eq.0 total
## 1 10 0.007097232 647 0.4591909 1409
For this game, it appears most of the responses should be under one second. Only 10 responses of 1409 were over 1 second. Many responses were 0 (comes from trials in which respondents were supposed to not tap. Not removing these skews averages). 647 were eaual to zero, which comes from the game structure. For the calculation of reaction times, we won’t want to include the 0s.
CTdf <- filter(Merge.2, game_name %in% CT)
CTdf <- CTdf[CTdf$response_reaction_time < 5000,]
nrow(CTdf)
## [1] 2580
#Recall handswype is the one that has the "checkpoint style"
#More trials = more successful on the task
#Our RT is less important here (although there is a correlation between RT and number correct)
HSdf <- filter(Merge.2, game_name =="hand swype")
HSdf <- HSdf[HSdf$response_reaction_time < 5000,]
nrow(HSdf)
## [1] 3095
#Note that for this one, we only want to count RTs of targets (distractors are 0)
QTdf <- filter(Merge.2, game_name =="quick tap level 2")
QTdf <- QTdf[QTdf$response_reaction_time < 1000,]
QTdf <- QTdf[QTdf$response_reaction_time > 0,]
nrow(QTdf)
## [1] 752
#Combining these three
RTno.out <- rbind(CTdf, QTdf, HSdf)
nrow(Merge.2)
## [1] 7149
nrow(RTno.out)
## [1] 6427
nrow(Merge.2)-nrow(RTno.out) #Should have removed 75 outlier responses and 647 0s from QT
## [1] 722
RTs <- RTno.out%>%
group_by(ID, timepoint, game_name)%>%
summarize(avgRT = mean(response_reaction_time, na.rm = TRUE))
## `summarise()` has grouped output by 'ID', 'timepoint'. You can override using the `.groups` argument.
RTs
## # A tibble: 437 × 4
## # Groups: ID, timepoint [89]
## ID timepoint game_name avgRT
## <fct> <dbl> <chr> <dbl>
## 1 101 1 color trick 1 896.
## 2 101 1 color trick 2 979.
## 3 101 1 color trick 3 1056.
## 4 101 1 hand swype 1655.
## 5 101 1 quick tap level 2 463.
## 6 101 2 color trick 1 711.
## 7 101 2 color trick 2 819.
## 8 101 2 color trick 3 1008.
## 9 101 2 hand swype 1796.
## 10 101 2 quick tap level 2 428.
## # … with 427 more rows
Correct <- Merge.2%>%
group_by(ID, timepoint, game_name)%>%
summarize(tot.correct = sum(is_response_correct == TRUE, na.rm = TRUE),
tot.incorrect = sum(is_response_correct == FALSE, na.rm = TRUE),
prop.correct = tot.correct/(tot.correct + tot.incorrect))
## `summarise()` has grouped output by 'ID', 'timepoint'. You can override using the `.groups` argument.
We see there are some ceiling effects here. Many people got the majority, if not all, of the questions correct. We will still use these, but we have to keep this in mind.
Game_Data <- merge(
x = Correct,
y = RTs,
by.x = c("ID", "timepoint", "game_name"),
by.y = c("ID", "timepoint", "game_name")
)
str(Game_Data)
## 'data.frame': 436 obs. of 7 variables:
## $ ID : Factor w/ 33 levels "101","102","103",..: 1 1 1 1 1 1 1 1 1 1 ...
## $ timepoint : num 1 1 1 1 1 2 2 2 2 2 ...
## $ game_name : chr "color trick 1" "color trick 2" "color trick 3" "hand swype" ...
## $ tot.correct : int 9 9 9 30 13 9 9 9 32 15 ...
## $ tot.incorrect: int 0 0 0 5 2 0 0 0 1 0 ...
## $ prop.correct : num 1 1 1 0.857 0.867 ...
## $ avgRT : num 896 979 1056 1655 463 ...
Game.Merge <- merge(
x = Game_Data,
y = IntKey,
by.x = "ID",
by.y = "ID"
)
PHQ.Corrs <- merge(
x = Game.Merge,
y = smile2,
by.x = c("Study.ID", "timepoint"),
by.y = c("StudyID_T1", "numTime"))
str(PHQ.Corrs)
## 'data.frame': 436 obs. of 15 variables:
## $ Study.ID : int 22585580 22585580 22585580 22585580 22585580 22585580 22585580 22585580 22585580 22585580 ...
## $ timepoint : num 1 1 1 1 1 2 2 2 2 2 ...
## $ ID : Factor w/ 33 levels "101","102","103",..: 1 1 1 1 1 1 1 1 1 1 ...
## $ game_name : chr "color trick 1" "color trick 2" "color trick 3" "hand swype" ...
## $ tot.correct : int 9 9 9 30 13 9 9 9 32 15 ...
## $ tot.incorrect : int 0 0 0 5 2 0 0 0 1 0 ...
## $ prop.correct : num 1 1 1 0.857 0.867 ...
## $ avgRT : num 896 979 1056 1655 463 ...
## $ X : chr "" "" "" "" ...
## $ NeurUX.ID : chr "user1" "user1" "user1" "user1" ...
## $ Headspace.ID : chr "SCILOY-139ZCT" "SCILOY-139ZCT" "SCILOY-139ZCT" "SCILOY-139ZCT" ...
## $ Intervention.Group: int 1 1 1 1 1 1 1 1 1 1 ...
## $ semester : num 1 1 1 1 1 1 1 1 1 1 ...
## $ Int.Fac : Factor w/ 2 levels "Control","Intervention": 2 2 2 2 2 2 2 2 2 2 ...
## $ PHQ.Score : num 16 16 16 16 16 10 10 10 10 10 ...
write.csv(PHQ.Corrs, "1204.Merge.csv")
This first plot above shows the correlation between reaction time and depression scores across all games and timepoints. Broadly, we see reaction time is not a great predictor of depression scores. We also see some counterintuitive relationships (such as in color trick 1, which seems to show faster reaction times are associated with higher levels of depression). There are also differences across time points. Quick tap has different relationships based on the timepoint.
These plots above show the relationship between correct answers and depression scores. We see the ceiling effects and how the relationships are driven by people who didn’t get 100% correct on some games. Hand swype is the only one with a reasonable amount of variability, but there is no association between these scores and depression. Color Trick 3 has an association, but it is counter-intuitive. Quick tap has a potentially significant relationship at time one, but we can go to data-driven approaches to confirm this.
PHQ.Corrs%>%
group_by(timepoint, game_name)%>%
summarize(cors = cor(PHQ.Score, avgRT))
## `summarise()` has grouped output by 'timepoint'. You can override using the `.groups` argument.
## # A tibble: 15 × 3
## # Groups: timepoint [3]
## timepoint game_name cors
## <dbl> <chr> <dbl>
## 1 1 color trick 1 -0.344
## 2 1 color trick 2 -0.206
## 3 1 color trick 3 -0.203
## 4 1 hand swype 0.104
## 5 1 quick tap level 2 0.159
## 6 2 color trick 1 -0.193
## 7 2 color trick 2 -0.0939
## 8 2 color trick 3 -0.136
## 9 2 hand swype 0.0749
## 10 2 quick tap level 2 -0.263
## 11 3 color trick 1 -0.0685
## 12 3 color trick 2 -0.310
## 13 3 color trick 3 -0.259
## 14 3 hand swype 0.257
## 15 3 quick tap level 2 0.352
Time1Corrs <- filter(PHQ.Corrs, timepoint == 1)
Time2Corrs <- filter(PHQ.Corrs, timepoint == 2)
Time3Corrs <- filter(PHQ.Corrs, timepoint == 3)
Time1Corrs.Wide <- pivot_wider(Time1Corrs,
id_cols = c(Study.ID, ID, NeurUX.ID, timepoint,
Headspace.ID, Intervention.Group, semester, Int.Fac,
PHQ.Score),
names_from = c(game_name),
values_from = c(tot.correct, tot.incorrect, prop.correct,
avgRT))
library(corrplot)
T1s <- data.frame(Time1Corrs.Wide[9:29])
T1s <- mutate_if(T1s, is.integer, as.numeric)
T1 <- cor(T1s)
#We can look at the full correlations, but all we care about is PHQ
corrplot(T1)
T1.Corrs <- data.frame(rbind(rownames(T1), T1[1:21]))
T1.Corrs <- data.frame(t(T1.Corrs))
T1.Corrs <- mutate(T1.Corrs, Corr = as.numeric(X2))
#Correct answers on quick tap are negatively associated with PHQ
#Incorrect answers on CT3 and CT1 reaction time are also negatively correlated (less so)
head(T1.Corrs[order(T1.Corrs$Corr),])
## X1 X2 Corr
## X6 tot.correct_quick.tap.level.2 -0.540560695789421 -0.5405607
## X16 prop.correct_quick.tap.level.2 -0.540560695789421 -0.5405607
## X9 tot.incorrect_color.trick.3 -0.374302470027265 -0.3743025
## X17 avgRT_color.trick.1 -0.34363839800115 -0.3436384
## X18 avgRT_color.trick.2 -0.20588258929485 -0.2058826
## X19 avgRT_color.trick.3 -0.203493084970735 -0.2034931
#Incorrect quick tap answers are positively correlated with PHQ
#Correct answers on CT3 are similarly positvely correlated (less so)
head(T1.Corrs[order(-T1.Corrs$Corr),])
## X1 X2 Corr
## X1 PHQ.Score 1 1.0000000
## X11 tot.incorrect_quick.tap.level.2 0.540560695789421 0.5405607
## X4 tot.correct_color.trick.3 0.374302470027265 0.3743025
## X14 prop.correct_color.trick.3 0.374302470027265 0.3743025
## X21 avgRT_quick.tap.level.2 0.159449315142514 0.1594493
## X3 tot.correct_color.trick.2 0.152402459522374 0.1524025
These results seem to suggest answering correctly on Quick Tap and missing questions on the most difficult Color Trick game are the best predictors of depression scores. Reaction times are not likely great predictors of depression scores. If any, we could look at reaction times from Color Trick 1. The color trick results are all counter-intuitive.
library(ggpubr)
#Negative Correlations
ggarrange(neg1, neg2, neg3, neg4,
labels = c("QT Total Correct", "QT Proportion Correct",
"CT3 Total Incorrect", "CT1 Reaction Time"))
#Positive Correlations
ggarrange(pos1,
ggarrange(pos2,
pos3,
ncol = 2,
labels = c("CT3 Total Correct", "CT3 Proportion Correct")),
nrow = 2, labels = "QT Total Incorrect")
These plots show Quick Tap is likely our only good proxy for depression on these games. This game requires seeing an image, processing it, and deciding whether to tap or inhibit a response based on that image.
#Note that the model has singularity problems because high level of overlap
#For example, correct and incorrect obviously are not independent.
lmod <- lm(PHQ.Score ~ ., data = T1s)
summary(lmod)
##
## Call:
## lm(formula = PHQ.Score ~ ., data = T1s)
##
## Residuals:
## Min 1Q Median 3Q Max
## -10.4379 -2.0941 0.5012 1.7280 7.0671
##
## Coefficients: (8 not defined because of singularities)
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 25.2400500 27.5292967 0.917 0.37135
## tot.correct_color.trick.1 0.1652423 1.9025915 0.087 0.93175
## tot.correct_color.trick.2 0.0893988 1.3674096 0.065 0.94859
## tot.correct_color.trick.3 1.5246408 0.6326337 2.410 0.02687 *
## tot.correct_hand.swype -0.0378204 0.1648541 -0.229 0.82113
## tot.correct_quick.tap.level.2 -2.7394663 0.9503382 -2.883 0.00991 **
## tot.incorrect_color.trick.1 NA NA NA NA
## tot.incorrect_color.trick.2 NA NA NA NA
## tot.incorrect_color.trick.3 NA NA NA NA
## tot.incorrect_hand.swype 0.3251302 0.3447474 0.943 0.35812
## tot.incorrect_quick.tap.level.2 NA NA NA NA
## prop.correct_color.trick.1 NA NA NA NA
## prop.correct_color.trick.2 NA NA NA NA
## prop.correct_color.trick.3 NA NA NA NA
## prop.correct_hand.swype 9.4122322 15.5691223 0.605 0.55303
## prop.correct_quick.tap.level.2 NA NA NA NA
## avgRT_color.trick.1 -0.0077450 0.0033451 -2.315 0.03260 *
## avgRT_color.trick.2 -0.0018515 0.0030241 -0.612 0.54802
## avgRT_color.trick.3 0.0032617 0.0031841 1.024 0.31922
## avgRT_hand.swype 0.0004805 0.0043112 0.111 0.91249
## avgRT_quick.tap.level.2 0.0136089 0.0117068 1.162 0.26022
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 4.188 on 18 degrees of freedom
## Multiple R-squared: 0.5844, Adjusted R-squared: 0.3073
## F-statistic: 2.109 on 12 and 18 DF, p-value: 0.07402
#This call shows us which predictors (1-9) should be included in the model
library(leaps)
AIC <- regsubsets(PHQ.Score ~ ., data = T1s)
## Warning in leaps.setup(x, y, wt = wt, nbest = nbest, nvmax = nvmax, force.in =
## force.in, : 8 linear dependencies found
## Reordering variables and trying again:
rs <- summary(AIC)
rs$which
## (Intercept) tot.correct_color.trick.1 tot.correct_color.trick.2
## 1 TRUE FALSE FALSE
## 2 TRUE FALSE FALSE
## 3 TRUE FALSE FALSE
## 4 TRUE FALSE FALSE
## 5 TRUE FALSE FALSE
## 6 TRUE FALSE FALSE
## 7 TRUE FALSE FALSE
## 8 TRUE FALSE FALSE
## 9 TRUE FALSE FALSE
## tot.correct_color.trick.3 tot.correct_hand.swype
## 1 FALSE FALSE
## 2 FALSE FALSE
## 3 FALSE FALSE
## 4 FALSE FALSE
## 5 TRUE FALSE
## 6 TRUE FALSE
## 7 TRUE FALSE
## 8 FALSE FALSE
## 9 FALSE TRUE
## tot.correct_quick.tap.level.2 tot.incorrect_color.trick.1
## 1 FALSE FALSE
## 2 FALSE FALSE
## 3 TRUE FALSE
## 4 FALSE FALSE
## 5 FALSE FALSE
## 6 TRUE FALSE
## 7 FALSE FALSE
## 8 FALSE FALSE
## 9 FALSE FALSE
## tot.incorrect_color.trick.2 tot.incorrect_color.trick.3
## 1 FALSE FALSE
## 2 FALSE FALSE
## 3 FALSE FALSE
## 4 FALSE TRUE
## 5 FALSE FALSE
## 6 FALSE FALSE
## 7 FALSE FALSE
## 8 FALSE TRUE
## 9 FALSE TRUE
## tot.incorrect_hand.swype tot.incorrect_quick.tap.level.2
## 1 FALSE FALSE
## 2 FALSE TRUE
## 3 FALSE FALSE
## 4 TRUE TRUE
## 5 TRUE TRUE
## 6 TRUE FALSE
## 7 TRUE TRUE
## 8 TRUE TRUE
## 9 TRUE TRUE
## prop.correct_color.trick.1 prop.correct_color.trick.2
## 1 FALSE FALSE
## 2 FALSE FALSE
## 3 FALSE FALSE
## 4 FALSE FALSE
## 5 FALSE FALSE
## 6 FALSE FALSE
## 7 FALSE FALSE
## 8 FALSE FALSE
## 9 FALSE FALSE
## prop.correct_color.trick.3 prop.correct_hand.swype
## 1 FALSE FALSE
## 2 FALSE FALSE
## 3 TRUE FALSE
## 4 FALSE FALSE
## 5 FALSE FALSE
## 6 FALSE FALSE
## 7 FALSE FALSE
## 8 FALSE TRUE
## 9 FALSE TRUE
## prop.correct_quick.tap.level.2 avgRT_color.trick.1 avgRT_color.trick.2
## 1 TRUE FALSE FALSE
## 2 FALSE TRUE FALSE
## 3 FALSE TRUE FALSE
## 4 FALSE TRUE FALSE
## 5 FALSE TRUE FALSE
## 6 FALSE TRUE FALSE
## 7 FALSE TRUE TRUE
## 8 FALSE TRUE TRUE
## 9 FALSE TRUE TRUE
## avgRT_color.trick.3 avgRT_hand.swype avgRT_quick.tap.level.2
## 1 FALSE FALSE FALSE
## 2 FALSE FALSE FALSE
## 3 FALSE FALSE FALSE
## 4 FALSE FALSE FALSE
## 5 FALSE FALSE TRUE
## 6 TRUE FALSE TRUE
## 7 TRUE FALSE TRUE
## 8 TRUE FALSE TRUE
## 9 TRUE FALSE TRUE
#We can plot it to see the best number of predictors
#We can get an idea of the optimal number of predictors based on the minimum of the plot
AIC2 <- 50*log(rs$rss/50) + (2:10)*2
plot(AIC2 ~ I(1:9), ylab = "AIC", xlab = "# of Predictors")
#We see five predictors are ideal
rs$which[5,]
## (Intercept) tot.correct_color.trick.1
## TRUE FALSE
## tot.correct_color.trick.2 tot.correct_color.trick.3
## FALSE TRUE
## tot.correct_hand.swype tot.correct_quick.tap.level.2
## FALSE FALSE
## tot.incorrect_color.trick.1 tot.incorrect_color.trick.2
## FALSE FALSE
## tot.incorrect_color.trick.3 tot.incorrect_hand.swype
## FALSE TRUE
## tot.incorrect_quick.tap.level.2 prop.correct_color.trick.1
## TRUE FALSE
## prop.correct_color.trick.2 prop.correct_color.trick.3
## FALSE FALSE
## prop.correct_hand.swype prop.correct_quick.tap.level.2
## FALSE FALSE
## avgRT_color.trick.1 avgRT_color.trick.2
## TRUE FALSE
## avgRT_color.trick.3 avgRT_hand.swype
## FALSE FALSE
## avgRT_quick.tap.level.2
## TRUE
#The command below shows us the five predictors are:
#CT3 Total Correct
#HS Total Incorrect
#QT Total Incorrect
#QT Reaction Time
#CT1 Reaction Time
#Adjusted R Square corrects for the number of predictors
#In this case, we see six predictors is the best option
plot(2:10, rs$adjr2, ylab = "Adj. R^2", xlab = "# of Parameters")
rs$which[6,]
## (Intercept) tot.correct_color.trick.1
## TRUE FALSE
## tot.correct_color.trick.2 tot.correct_color.trick.3
## FALSE TRUE
## tot.correct_hand.swype tot.correct_quick.tap.level.2
## FALSE TRUE
## tot.incorrect_color.trick.1 tot.incorrect_color.trick.2
## FALSE FALSE
## tot.incorrect_color.trick.3 tot.incorrect_hand.swype
## FALSE TRUE
## tot.incorrect_quick.tap.level.2 prop.correct_color.trick.1
## FALSE FALSE
## prop.correct_color.trick.2 prop.correct_color.trick.3
## FALSE FALSE
## prop.correct_hand.swype prop.correct_quick.tap.level.2
## FALSE FALSE
## avgRT_color.trick.1 avgRT_color.trick.2
## TRUE FALSE
## avgRT_color.trick.3 avgRT_hand.swype
## TRUE FALSE
## avgRT_quick.tap.level.2
## TRUE
#The added predictor is reaction time for CT3
#Mallow's CP suggests 3 predictors may be ideal
plot(2:10, rs$cp, ylab = "CP Statistic", xlab = "# of Parameters")
rs$which[3,] #The only three are QT total correct, CT1 reaction time, and CT3 proportion correct
## (Intercept) tot.correct_color.trick.1
## TRUE FALSE
## tot.correct_color.trick.2 tot.correct_color.trick.3
## FALSE FALSE
## tot.correct_hand.swype tot.correct_quick.tap.level.2
## FALSE TRUE
## tot.incorrect_color.trick.1 tot.incorrect_color.trick.2
## FALSE FALSE
## tot.incorrect_color.trick.3 tot.incorrect_hand.swype
## FALSE FALSE
## tot.incorrect_quick.tap.level.2 prop.correct_color.trick.1
## FALSE FALSE
## prop.correct_color.trick.2 prop.correct_color.trick.3
## FALSE TRUE
## prop.correct_hand.swype prop.correct_quick.tap.level.2
## FALSE FALSE
## avgRT_color.trick.1 avgRT_color.trick.2
## TRUE FALSE
## avgRT_color.trick.3 avgRT_hand.swype
## FALSE FALSE
## avgRT_quick.tap.level.2
## FALSE
lmodAIC <- lm(PHQ.Score ~ tot.correct_color.trick.3 +
tot.correct_hand.swype +
tot.correct_quick.tap.level.2 +
avgRT_quick.tap.level.2 +
avgRT_color.trick.1 , data = T1s)
summary(lmodAIC)
##
## Call:
## lm(formula = PHQ.Score ~ tot.correct_color.trick.3 + tot.correct_hand.swype +
## tot.correct_quick.tap.level.2 + avgRT_quick.tap.level.2 +
## avgRT_color.trick.1, data = T1s)
##
## Residuals:
## Min 1Q Median 3Q Max
## -10.7412 -1.4316 0.1761 2.1705 5.8706
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 42.188672 14.519416 2.906 0.00757 **
## tot.correct_color.trick.3 0.820505 0.458782 1.788 0.08583 .
## tot.correct_hand.swype 0.027039 0.082182 0.329 0.74488
## tot.correct_quick.tap.level.2 -2.593127 0.838643 -3.092 0.00483 **
## avgRT_quick.tap.level.2 0.014363 0.010137 1.417 0.16888
## avgRT_color.trick.1 -0.006899 0.002867 -2.406 0.02384 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 3.877 on 25 degrees of freedom
## Multiple R-squared: 0.5054, Adjusted R-squared: 0.4065
## F-statistic: 5.11 on 5 and 25 DF, p-value: 0.002307
#We see that missing questions on quick tap is associated with depression
#Slower reaction times on color trick 1 are associated with more depression
#More correct questions on color trick 3 are asssociated with more depression
lmodRsq <- lm(PHQ.Score ~ tot.correct_color.trick.3 +
tot.correct_hand.swype +
tot.correct_quick.tap.level.2 +
avgRT_quick.tap.level.2 +
avgRT_color.trick.1 +
avgRT_color.trick.3, data = T1s)
summary(lmodRsq)
##
## Call:
## lm(formula = PHQ.Score ~ tot.correct_color.trick.3 + tot.correct_hand.swype +
## tot.correct_quick.tap.level.2 + avgRT_quick.tap.level.2 +
## avgRT_color.trick.1 + avgRT_color.trick.3, data = T1s)
##
## Residuals:
## Min 1Q Median 3Q Max
## -11.2084 -1.9690 -0.2918 2.2499 5.3042
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 41.573449 14.512514 2.865 0.00854 **
## tot.correct_color.trick.3 0.964304 0.478877 2.014 0.05539 .
## tot.correct_hand.swype 0.039103 0.082901 0.472 0.64141
## tot.correct_quick.tap.level.2 -2.826667 0.867543 -3.258 0.00333 **
## avgRT_quick.tap.level.2 0.014752 0.010131 1.456 0.15832
## avgRT_color.trick.1 -0.007794 0.002992 -2.605 0.01552 *
## avgRT_color.trick.3 0.001921 0.001861 1.032 0.31213
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 3.872 on 24 degrees of freedom
## Multiple R-squared: 0.5265, Adjusted R-squared: 0.4081
## F-statistic: 4.447 on 6 and 24 DF, p-value: 0.003678
#Here, the same predictors are all significant
lmodMallow <- lm(PHQ.Score ~ tot.correct_quick.tap.level.2 +
tot.correct_color.trick.3 +
avgRT_color.trick.1, data = T1s)
summary(lmodMallow)
##
## Call:
## lm(formula = PHQ.Score ~ tot.correct_quick.tap.level.2 + tot.correct_color.trick.3 +
## avgRT_color.trick.1, data = T1s)
##
## Residuals:
## Min 1Q Median 3Q Max
## -11.709 -1.705 -0.306 2.470 6.339
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 49.034265 13.573190 3.613 0.00122 **
## tot.correct_quick.tap.level.2 -2.482967 0.828985 -2.995 0.00581 **
## tot.correct_color.trick.3 0.788021 0.456678 1.726 0.09586 .
## avgRT_color.trick.1 -0.007158 0.002803 -2.553 0.01663 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 3.884 on 27 degrees of freedom
## Multiple R-squared: 0.4639, Adjusted R-squared: 0.4043
## F-statistic: 7.788 on 3 and 27 DF, p-value: 0.0006667
#Total correct on quick tap was negatively associated with depression
#Slower reaction times on color trick one were also negatively associated with depression
#The
QT <- filter(PHQ.Corrs, game_name == "quick tap level 2")
str(QT)
## 'data.frame': 88 obs. of 15 variables:
## $ Study.ID : int 22585580 22585580 22585580 22585581 22585581 22585581 22585582 22585582 22585582 22585583 ...
## $ timepoint : num 1 2 3 1 2 3 1 2 3 2 ...
## $ ID : Factor w/ 33 levels "101","102","103",..: 1 1 1 7 7 7 11 11 11 14 ...
## $ game_name : chr "quick tap level 2" "quick tap level 2" "quick tap level 2" "quick tap level 2" ...
## $ tot.correct : int 13 15 14 15 15 15 14 15 15 14 ...
## $ tot.incorrect : int 2 0 1 0 0 0 1 0 0 1 ...
## $ prop.correct : num 0.867 1 0.933 1 1 ...
## $ avgRT : num 463 428 421 488 447 ...
## $ X : chr "" "" "" "" ...
## $ NeurUX.ID : chr "user1" "user1" "user1" "user7" ...
## $ Headspace.ID : chr "SCILOY-139ZCT" "SCILOY-139ZCT" "SCILOY-139ZCT" "SCILOY-NDWT0Q" ...
## $ Intervention.Group: int 1 1 1 1 1 1 1 1 1 1 ...
## $ semester : num 1 1 1 1 1 1 1 1 1 1 ...
## $ Int.Fac : Factor w/ 2 levels "Control","Intervention": 2 2 2 2 2 2 2 2 2 2 ...
## $ PHQ.Score : num 16 10 4 9 9 9 17 18 15 22 ...
QT%>%
ggplot(aes(x = timepoint, y = prop.correct)) +
geom_jitter(alpha = .5, width = .1)+
geom_smooth(method = "lm", formula = "y ~ x")
QT%>%
ggplot(aes(x = timepoint, y = prop.correct)) +
geom_jitter(alpha = .5, width = .1)+
geom_smooth(method = "lm", formula = "y ~ x")+
facet_wrap(.~Int.Fac)
QT$ID.Fac <- factor(QT$ID)
QT%>%
ggplot(aes(x = timepoint, y = tot.correct, color = ID.Fac))+
geom_point()+
geom_smooth(se = FALSE,
method = "lm",
formula = "y ~ x",
size = .5)+
facet_wrap(.~Int.Fac)+
theme(legend.position = "none")
QT%>%
filter(Int.Fac == "Control")%>%
ggplot(aes(x = timepoint, y = tot.correct))+
geom_point()+
geom_smooth(se = FALSE,
method = "lm",
formula = "y ~ x",
lty = "dashed",
size = .5)+
facet_wrap(.~ID.Fac)
QT%>%
filter(Int.Fac == "Intervention")%>%
ggplot(aes(x = timepoint, y = tot.correct))+
geom_point()+
geom_smooth(se = FALSE,
method = "lm",
formula = "y ~ x",
lty = "dashed",
size = .5)+
facet_wrap(.~ID.Fac)
QTmod <- lm(tot.correct ~ timepoint, data = QT)
summary(QTmod)
##
## Call:
## lm(formula = tot.correct ~ timepoint, data = QT)
##
## Residuals:
## Min 1Q Median 3Q Max
## -4.1718 -0.2789 0.6568 0.7425 0.8282
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 14.42885 0.27594 52.289 <2e-16 ***
## timepoint -0.08569 0.13041 -0.657 0.513
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.9916 on 86 degrees of freedom
## Multiple R-squared: 0.004996, Adjusted R-squared: -0.006574
## F-statistic: 0.4318 on 1 and 86 DF, p-value: 0.5129
Intmod <- lm(tot.correct ~ timepoint + Int.Fac + timepoint:Int.Fac, data = QT)
summary(Intmod)
##
## Call:
## lm(formula = tot.correct ~ timepoint + Int.Fac + timepoint:Int.Fac,
## data = QT)
##
## Residuals:
## Min 1Q Median 3Q Max
## -3.5802 -0.3338 0.5649 0.6807 1.4198
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 14.8626 0.5507 26.987 <2e-16 ***
## timepoint -0.4275 0.2651 -1.613 0.111
## Int.FacIntervention -0.5724 0.6348 -0.902 0.370
## timepoint:Int.FacIntervention 0.4420 0.3039 1.455 0.150
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.9844 on 84 degrees of freedom
## Multiple R-squared: 0.04218, Adjusted R-squared: 0.007973
## F-statistic: 1.233 on 3 and 84 DF, p-value: 0.3029